From: Camm Maguire Date: Tue, 21 Apr 2026 12:11:46 +0000 (+0000) Subject: [PATCH] X-Git-Tag: archive/raspbian/2.7.1-33+rpi1^2^2~19 X-Git-Url: https://dgit.raspbian.org/%22http://www.example.com/cgi/%22/%22http:/www.example.com/cgi/%22?a=commitdiff_plain;h=779966414ad1b04316d6b6d49fa7a6cc7da4c264;p=gcl27.git [PATCH] TODO: Put a short summary on the line above and replace this paragraph with a longer explanation of this change. Complete the meta-information with other relevant fields (see below for details). To make it easier, the information below has been extracted from the changelog. Adjust it or drop it. Gbp-Pq: Name Version_2_7_2pre16 --- diff --git a/ansi-tests/read-byte.lsp b/ansi-tests/read-byte.lsp index 32757439..84ddbdcf 100644 --- a/ansi-tests/read-byte.lsp +++ b/ansi-tests/read-byte.lsp @@ -79,6 +79,22 @@ collect (list i b1 b2)) nil) +(deftest read-byte.5 + (let ((s (open "foo.txt" + :direction :output + :if-exists :supersede + :element-type '(unsigned-byte 8)))) + (values + (write-byte 255 s) + (close s) + (progn + (setq s (open "foo.txt" + :direction :input + :element-type '(signed-byte 8))) + (read-byte s)) + (close s))) + 255 t -1 t) + ;;; Error tests (deftest read-byte.error.1 diff --git a/ansi-tests/read-sequence.lsp b/ansi-tests/read-sequence.lsp index 0250aac8..ac05a2f4 100644 --- a/ansi-tests/read-sequence.lsp +++ b/ansi-tests/read-sequence.lsp @@ -171,6 +171,12 @@ (make-array 10 :initial-element nil :fill-pointer 5) (:end nil) "abcdefghijk" 5 #(#\a #\b #\c #\d #\e)) +;; Fast read-sequence + +(def-read-sequence-test read-sequence.fast-char.1 + (make-array 5 :element-type 'character) + (:end nil) "abcdefghijk" 5 "abcde") + ;;; Nil vectors (deftest read-sequence.nil-vector.1 @@ -231,6 +237,63 @@ (def-read-sequence-bv-test read-sequence.bv.7 #*00000000000000 (:end 6) 6 #*01100100000000) +;; Fast read-sequence -> fread cases + +(defmacro def-read-sequence-fread-test (name seql tp data args &rest expected) + `(deftest ,name + ;; Create output file + (progn + (let (os) + (unwind-protect + (progn + (setq os (open "temp.dat" :direction :output + :element-type ',tp + :if-exists :supersede)) + (loop for i in (coerce ,data 'list) + do (if (eq ',tp 'character) (write-char i os) (write-byte i os)))) + (when os (close os)))) + (let (is (seq (make-array ,seql :element-type ',tp))) + (unwind-protect + (progn + (setq is (open "temp.dat" :direction :input + :element-type ',tp)) + (values + (read-sequence seq is ,@args) + seq)) + (when is (close is))))) + ,@expected)) + +(def-read-sequence-fread-test + read-sequence.fread.1 20 + character "abcdefghijk" () + 11 "abcdefghijk ") + +(def-read-sequence-fread-test + read-sequence.fread.2 20 + character "abcdefghijk" (:start 1) + 12 " abcdefghijk ") + +(def-read-sequence-fread-test + read-sequence.fread.3 20 + character "abcdefghijk" (:start 1 :end 3) + 3 " ab ") + +(def-read-sequence-fread-test + read-sequence.fread.4 20 + character "abcdefghijk" (:end 3) + 3 "abc ") + +(def-read-sequence-fread-test + read-sequence.fread.5 20 + fixnum #(1 2 3 4 5 6 7 8 9 10 11) (:end 3) + 3 #(1 2 3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)) + +(def-read-sequence-fread-test + read-sequence.fread.6 20 + (unsigned-byte 16) #(1 2 3 4 5 6 7 8 9 10 11) (:start 2 :end 6) + 6 #(0 0 1 2 3 4 0 0 0 0 0 0 0 0 0 0 0 0 0 0)) + + ;;; Error cases (deftest read-sequence.error.1 diff --git a/ansi-tests/write-sequence.lsp b/ansi-tests/write-sequence.lsp index c16ef8e5..781be0ae 100644 --- a/ansi-tests/write-sequence.lsp +++ b/ansi-tests/write-sequence.lsp @@ -115,19 +115,19 @@ (defmacro def-write-sequence-bv-test (name input args expected) `(deftest ,name - (let ((s ,input) - (expected ,expected)) - (with-open-file - (os "tmp.dat" :direction :output - :element-type '(unsigned-byte 8) - :if-exists :supersede) - (assert (eq (write-sequence s os ,@args) s))) - (with-open-file - (is "tmp.dat" :direction :input - :element-type '(unsigned-byte 8)) - (loop for i from 0 below (length expected) - for e = (elt expected i) - always (eql (read-byte is) e)))) + (let ((s ,input) + (expected ,expected)) + (with-open-file + (os "tmp.dat" :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede) + (assert (eq (write-sequence s os ,@args) s))) + (with-open-file + (is "tmp.dat" :direction :input + :element-type '(unsigned-byte 8)) + (loop for i from 0 below (length expected) + for e = (elt expected i) + always (eql (read-byte is) e)))) t)) (def-write-sequence-bv-test write-sequence.bv.1 #*00111010 @@ -143,6 +143,43 @@ (def-write-sequence-bv-test write-sequence.bv.6 #*00111010 (:start 1 :end nil :end 4) #*0111010) +(defmacro def-write-sequence-tp-test (name tp input args expected) + `(deftest ,name + (let ((s (coerce ',input `(vector ,',tp))) + (expected ',expected)) + (with-open-file + (os "tmp.dat" :direction :output + :element-type ',tp + :if-exists :supersede) + (assert (eq (write-sequence s os ,@args) s))) + (with-open-file + (is "tmp.dat" :direction :input + :element-type ',tp) + (loop for i from 0 below (length expected) + for e = (elt expected i) + always (eql (if (eq ',tp 'character) (read-char is) (read-byte is)) e)))) + t)) + +(def-write-sequence-tp-test write-sequence.tp.1 (unsigned-byte 8) + (1 2 3 4 5 6 7 8 9 10) () (1 2 3 4 5 6 7 8 9 10)) +(def-write-sequence-tp-test write-sequence.tp.2 (unsigned-byte 16) + (1 2 3 4 5 6 7 8 9 10) () (1 2 3 4 5 6 7 8 9 10)) +(def-write-sequence-tp-test write-sequence.tp.3 (signed-byte 32) + (1 2 3 4 5 6 7 8 9 10) () (1 2 3 4 5 6 7 8 9 10)) +(def-write-sequence-tp-test write-sequence.tp.4 (signed-byte 64) + (1 2 3 4 5 6 7 8 9 10) () (1 2 3 4 5 6 7 8 9 10)) +(def-write-sequence-tp-test write-sequence.tp.5 (unsigned-byte 128) + (1 2 3 4 5 6 7 8 9 10) () (1 2 3 4 5 6 7 8 9 10)) +(def-write-sequence-tp-test write-sequence.tp.6 character + (#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\1) () (#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\1)) +(def-write-sequence-tp-test write-sequence.tp.7 (unsigned-byte 16) + (1 2 3 4 5 6 7 8 9 10) (:start 1) (2 3 4 5 6 7 8 9 10)) +(def-write-sequence-tp-test write-sequence.tp.8 (unsigned-byte 16) + (1 2 3 4 5 6 7 8 9 10) (:end 4) (1 2 3)) +(def-write-sequence-tp-test write-sequence.tp.9 (unsigned-byte 16) + (1 2 3 4 5 6 7 8 9 10) (:start 1 :end 4) (2 3)) +(def-write-sequence-tp-test write-sequence.tp.10 (unsigned-byte 16) + (1 2 3 4 5 6 7 8 9 10) (:start 1 :end nil :end 4) (2 3 4 5 6 7 8 9 10)) ;;; Error tests diff --git a/cmpnew/gcl_cmpcall.lsp b/cmpnew/gcl_cmpcall.lsp index 6ff2fd1e..cbf0736a 100644 --- a/cmpnew/gcl_cmpcall.lsp +++ b/cmpnew/gcl_cmpcall.lsp @@ -483,18 +483,16 @@ (defun stub-decl (name args d &optional vp &aux (i 0)) - (concatenate - 'string + (ms "static " d " " name ;" LnkT" num "(" - (apply 'concatenate 'string - (mapcan (lambda (x) - (if (eq x '*) - (list ",...") - (list (if (plusp i) "," "") - (rep-type x) - (progn (incf i) (if vp (concatenate 'string "x" (write-to-string i)) ""))))) - (if (eq (car args) '*) (cons t args) args))) + (mapcan (lambda (x) + (if (eq x '*) + (list ",...") + (list (if (plusp i) "," "") + (rep-type x) + (progn (incf i) (if vp (list "x" (write-to-string i)) ""))))) + (if (eq (car args) '*) (cons t args) args)) ")")) @@ -503,8 +501,7 @@ (i (max n (- (length args) n)));FIXME (si (write-to-string i)) (d (declaration-type (rep-type (if (link-arg-p type) type t))))) - (concatenate - 'string + (ms (stub-decl (concatenate 'string "LnkT" num) args d t) "{ int nargs=" (if va "fcall.argd<0 ? -fcall.argd : fcall.argd" si) "; @@ -512,14 +509,12 @@ " (let ((j 0)) - (apply 'concatenate 'string - (mapcan (lambda (x &aux (sj (write-to-string (incf j)))) - (declare (ignore x)) - (list "FOO[" sj "-1]=(object)x" sj ";")) - (make-list i)))) + (mapcan (lambda (x &aux (sj (write-to-string (incf j)))) + (declare (ignore x)) + (list "FOO[" sj "-1]=(object)x" sj ";")) + (make-list i))) (when va - (concatenate - 'string + (list " { va_list ap; @@ -539,6 +534,7 @@ "FOO); }")) + (defun wt-function-link (x) (let* ((name (pop x)) (num (pop x)) diff --git a/cmpnew/gcl_cmpfun.lsp b/cmpnew/gcl_cmpfun.lsp index eb0c288d..8f802f76 100644 --- a/cmpnew/gcl_cmpfun.lsp +++ b/cmpnew/gcl_cmpfun.lsp @@ -427,7 +427,6 @@ ;(si::putprop 'read-byte 'co1read-byte 'co1) #-cygwin(si::putprop 'read-char 'co1read-char 'co1) -(si::putprop 'write-byte 'co1write-byte 'co1) (si::putprop 'write-char 'co1write-char 'co1) (defun fast-read (args read-fun) @@ -483,15 +482,6 @@ (declare (type ,(result-type stream) ,str)) ,(cfast-write (list (car args) str) write-fun tp))))))) - -(defun co1write-byte (f args) - (declare (ignore f)) - (let ((tem (cfast-write args 'write-byte 'fixnum))) - (when tem - (let ((*space* 10)) - (c1expr tem))))) - - (defun co1write-char (f args) (declare (ignore f)) (let* ((tem (cfast-write args 'write-char 'character))) diff --git a/cmpnew/gcl_cmptop.lsp b/cmpnew/gcl_cmptop.lsp index a325fc5c..9caef52e 100644 --- a/cmpnew/gcl_cmptop.lsp +++ b/cmpnew/gcl_cmptop.lsp @@ -844,7 +844,7 @@ (cond (f (setq inl (lit-string-merge inl (fourth f) i lna (1- lff))) (setq lev (min lev 1));FIXME? ; (when (> lev (seventh f)) (setq lev (seventh f))); (break) - (incf i lff)(copy-list ff));FIXME? + (incf i lff)(incf lna (1- lff))(copy-list ff));FIXME? ((incf i)(list x)))) nargs)) (form (list 'lit info key inl nargs nil lev oargs nil (make-vs info)))) diff --git a/git.tag b/git.tag index ec638e13..d5b521e4 100644 --- a/git.tag +++ b/git.tag @@ -1 +1 @@ -"Version_2_7_2pre15" +"Version_2_7_2pre16" diff --git a/lsp/gcl_iolib.lsp b/lsp/gcl_iolib.lsp index 8abf0fa7..85a0fbdb 100644 --- a/lsp/gcl_iolib.lsp +++ b/lsp/gcl_iolib.lsp @@ -347,18 +347,41 @@ )) -(defun restrict-stream-element-type (tp) - (cond ((member tp '(unsigned-byte signed-byte)) tp) - ((or (member tp '(character :default)) (subtypep tp 'character)) 'character) +(defun encapsulate-stream-element-type (tp) + (cond ((subtypep tp 'character) 'character) ((subtypep tp 'integer) (let* ((ntp (tp-bnds (cmp-norm-tp tp))) (min (car ntp))(max (cdr ntp)) (s (if (or (eq min '*) (< min 0)) 'signed-byte 'unsigned-byte)) (lim (unless (or (eq min '*) (eq max '*)) (max (integer-length min) (integer-length max)))) (lim (if (and lim (eq s 'signed-byte)) (1+ lim) lim))) - (if lim `(,s ,lim) s))) + (if lim `(,s ,lim) s))))) + +(defconstant +array-stream-types+ (coerce (mapcar 'encapsulate-stream-element-type +array-types+) '(vector t))) + +(defun restrict-stream-element-type (tp &aux etp);standardize.... + (cond ((member tp '(:default character)) 'character) + ((eq tp 'unsigned-byte) '(unsigned-byte 8)) + ((eq tp 'signed-byte) '(signed-byte 8)) + ((typep tp '(cons (member unsigned-byte signed-byte) (cons (integer 0) null))) + (let ((tp (list (car tp) (* char-length (ceiling (cadr tp) char-length))))) + (or (find tp +array-stream-types+ :test 'equal) tp))) + ((subtypep tp 'character) 'character) + ((setq etp (encapsulate-stream-element-type tp)) + (restrict-stream-element-type etp)) ((check-type tp (member character integer))))) +(defun stream-fp (strm outp) + (when (open-stream-p strm) + (typecase strm + (file-synonym-stream (stream-fp (symbol-value (synonym-stream-symbol strm)) outp)) + (two-way-stream (stream-fp + (if outp (two-way-stream-output-stream strm) (two-way-stream-input-stream strm)) + outp)) + (file-io-stream (c-stream-fp strm)) + (file-input-stream (unless outp (c-stream-fp strm))) + (file-output-stream (when outp (c-stream-fp strm)))))) + (defun load-pathname-exists (z) (or (probe-file z) (when *allow-gzipped-file* @@ -417,54 +440,110 @@ (declare (optimize (safety 1))) (parse-integer-int s start end radix junk-allowed)) -(defun write-byte (j s &aux (i j)) +(defun stream-element-type (s) + (declare (optimize (safety 1))) + (check-type s stream);etypecase + (typecase s + ((or broadcast-stream concatenated-stream) + (let ((o (c-stream-object0 s))) + (when o (stream-element-type (car o))))) + ((or two-way-stream echo-stream) + (stream-element-type (c-stream-object0 s))) + (synonym-stream + (stream-element-type (symbol-value (c-stream-object0 s)))) + (file-stream;define socket + (c-stream-object0 s)) + (t 'character))) + +(deftype binary-stream-element-type nil 'list) +(defconstant +char-shft+ (1- (integer-length char-length))) + +(defun read-byte (s &optional (eof-error-p t) eof-value &aux (i 0)(tp (stream-element-type s))) (declare (optimize (safety 1))) - (check-type j integer) (check-type s stream) - (dotimes (k (get-byte-stream-nchars s) j) - (write-char (code-char (logand i #.(1- (ash 1 char-length)))) s) - (setq i (ash i #.(- char-length))))) + (check-type tp binary-stream-element-type) + (let* ((n (if tp (ash (cadr tp) (- +char-shft+)) 1))) + (dotimes (k n (let ((nb (ash n +char-shft+))) + (if (when (eq (car tp) 'signed-byte) (logbitp (1- nb) i)) (- i (ash 1 nb)) i))) + (setq i (logior i (ash (let ((ch (read-char s eof-error-p eof-value))) + (if (eq ch eof-value) (return ch) (char-code ch))) + (ash k +char-shft+))))))) + +(defun write-byte (j s &aux (i j) (tp (stream-element-type s))) + (declare (optimize (safety 1))) + (check-type j integer) + (check-type tp binary-stream-element-type) + (let ((n (ash (cadr tp) (- +char-shft+)))) + (dotimes (k n j) + (write-char (code-char (logand i #.(1- (ash 1 char-length)))) s) + (setq i (ash i #.(- char-length)))))) + +#-pre-gcl +(defdlfun (:fixnum "fread") :fixnum :fixnum :fixnum :fixnum) + +(defun read-sequence-using-fread (seq strm tp start end &aux (fp (stream-fp strm nil))) + #+pre-gcl + (declare (ignore seq tp start end fp)) + #-pre-gcl + (when fp + (when (eq tp (aref +array-stream-types+ (c-array-elttype seq))) + (let* ((n (ash 1 (1- (c-array-eltsize seq))))(ln (length seq))(end (or end ln))) + (when (<= start end ln) + (c+ start + (|libc|:|fread| + (c+ (c-array-self seq) (c* n start)) n (c- end start) fp))))))) -(defun read-byte (s &optional (eof-error-p t) eof-value &aux (i 0)) - (declare (optimize (safety 1))) - (check-type s stream) - (dotimes (k (get-byte-stream-nchars s) i) - (setq i (logior i (ash (let ((ch (read-char s eof-error-p eof-value))) - (if (eq ch eof-value) (return ch) (char-code ch))) - (* k char-length)))))) (defun read-sequence (seq strm &key (start 0) end &aux (l (listp seq))(seqp (when l (nthcdr start seq))) - (cp (eq (stream-element-type strm) 'character))) + (tp (stream-element-type strm))) (declare (optimize (safety 1)));FIXME (check-type seq sequence) (check-type strm stream) - (check-type start (integer 0)) - (check-type end (or null (integer 0))) - (labels ((set-cons (x z) (check-type x cons) (setf (car x) z) (cdr x))) - (the seqbnd - (reduce (lambda (y x &aux (z (if cp (read-char strm nil 'eof) (read-byte strm nil 'eof)))) - (declare (seqind y)(ignorable x)) - (when (eq z 'eof) (return-from read-sequence y)) - (if l (setq seqp (set-cons seqp z)) (setf (aref seq y) z)) - (1+ y)) - seq :initial-value start :start start :end end)))) + (check-type start seqind) + (check-type end (or null seqind)) + (the seqbnd + (or (unless l (read-sequence-using-fread seq strm tp start end)) + (labels ((set-cons (x z) (check-type x cons) (setf (car x) z) (cdr x)) + (mread nil (if (eq tp 'character) (read-char strm nil 'eof) (read-byte strm nil 'eof)))) + (reduce (lambda (y x &aux (z (mread))) + (declare (seqind y)(ignorable x)) + (when (eq z 'eof) (return-from read-sequence y)) + (if l (setq seqp (set-cons seqp z)) (setf (aref seq y) z)) + (1+ y)) + seq :initial-value start :start start :end end))))) + +#-pre-gcl +(defdlfun (:fixnum "fwrite") :fixnum :fixnum :fixnum :fixnum) + +(defun write-sequence-using-fwrite (seq strm tp start end &aux (fp (stream-fp strm t))) + #+pre-gcl + (declare (ignore seq tp start end fp)) + #-pre-gcl + (when fp + (when (eq tp (aref +array-stream-types+ (c-array-elttype seq))) + (let* ((n (ash 1 (1- (c-array-eltsize seq))))(ln (length seq))(end (or end ln))) + (when (<= start end ln) + (c+ start + (|libc|:|fwrite| + (c+ (c-array-self seq) (c* n start)) n (c- end start) fp))))))) (defun write-sequence (seq strm &key (start 0) end - &aux (cp (eq (stream-element-type strm) 'character))) + &aux (tp (stream-element-type strm))) (declare (optimize (safety 1))) (check-type seq sequence) (check-type strm stream) (check-type start (integer 0)) (check-type end (or null (integer 0))) - (reduce (lambda (y x) - (declare (seqind y)) - (if cp (write-char x strm) (write-byte x strm)) - (1+ y)) - seq :initial-value start :start start :end end) + (or (unless (listp seq) (write-sequence-using-fwrite seq strm tp start end)) + (reduce (lambda (y x) + (declare (seqind y)) + (if (eq tp 'character) (write-char x strm) (write-byte x strm)) + (1+ y)) + seq :initial-value start :start start :end end)) seq) (defun open (f &key (direction :input) @@ -481,6 +560,11 @@ if-exists iesp if-does-not-exist idnesp external-format))) (when (typep s 'stream) (c-set-stream-object1 s pf) s))) +(defun open-stream-p (strm) + (declare (optimize (safety 1))) + (check-type strm stream) + (not (logbitp #.(let ((s (open "/dev/null")))(close s) (1- (integer-length (c-stream-flags s)))) + (c-stream-flags strm)))) (defun file-length (x) (declare (optimize (safety 1))) diff --git a/o/error.c b/o/error.c index 20f48547..5ab57b83 100644 --- a/o/error.c +++ b/o/error.c @@ -400,9 +400,9 @@ void check_arg_failed(int n) { if (nsm.sm_mode) { - case smm_input: - case smm_output: - case smm_io: - case smm_probe: - return(strm->sm.sm_object0); - - case smm_socket: - return (sLcharacter); - - case smm_file_synonym: - case smm_synonym: - strm = symbol_value(strm->sm.sm_object0); - if (type_of(strm) != t_stream) - FEwrong_type_argument(sLstream, strm); - goto BEGIN; - - case smm_broadcast: - x = strm->sm.sm_object0; - if (endp(x)) - return(Ct); - return(stream_element_type(x->c.c_car)); - - case smm_concatenated: - x = strm->sm.sm_object0; - if (endp(x)) - return(Ct); - return(stream_element_type(x->c.c_car)); - - case smm_two_way: - return(stream_element_type(STREAM_INPUT_STREAM(strm))); - - case smm_echo: - return(stream_element_type(STREAM_INPUT_STREAM(strm))); - - case smm_string_input: - return(sLcharacter); - - case smm_string_output: - return(sLcharacter); - - default: - FEerror("Illegal stream mode for ~S.",1,strm); - return(FALSE); - } -} - void setup_stream_buffer(object x) { #ifdef NO_SETBUF @@ -1972,14 +1919,6 @@ LFD(Loutput_stream_p)() vs_base[0] = Cnil; } -LFD(Lstream_element_type)() -{ - check_arg(1); - - check_type_stream(&vs_base[0]); - vs_base[0] = stream_element_type(vs_base[0]); -} - @(defun close (strm &key abort) @ check_type_stream(&strm); @@ -2856,7 +2795,6 @@ gcl_init_file_function() make_function("STREAMP", Lstreamp); make_function("INPUT-STREAM-P", Linput_stream_p); make_function("OUTPUT-STREAM-P", Loutput_stream_p); - make_function("STREAM-ELEMENT-TYPE", Lstream_element_type); make_function("CLOSE", Lclose); /* make_si_function("OPEN1", Lopen1); */